perm filename SLURXG.FAI[NEW,LCS] blob sn#469454 filedate 1979-08-24 generic text, type T, neo UTF8
	TITLE SLURXG
	ENTRY SLUR
	EXTERNAL .COMM.,PLTR,ALF,SSS,SLR,PTR,LIMIT,STF

SLUR:	0		;	SUBROUTINE SLUR
	MOVEI 1,1	;	IMPLICIT INTEGER(A-Q,T-Z)
	MOVEM 1,.COMM.+=31;COMMON /ALF/INP,SLURY(72) /SSS/ SSS(200) /SLR/ SLURX(1)  
	SETZM .COMM.+=25	;	REAL CENTR
	MOVEI 5,5	;	COMMON /PLTR/PLT,RHT,RDIS,XDIS
	MOVEM 5,.COMM.+=15;	COMMON R2,JA,CENTR,J2,R3,R4,R5,R6,R7,R8,R9,R10,RA,RB,
	SETOM TWICE#	;	1 K,KQ,TWICE,RST7,RX,RXX,RTILT,RC,RZ,RW,J3,J4,
	SKIPL PLTR	;	1 J5,J6,J7,J8,J9,J10,J11,JQ(7),R,RJ
	JRST S21	;1 /PTR/PWDS(1) /LIMIT/LIMIT,ITEM,L,I,IX /STF/RSTFAC(0/7),RSTJ2
	SETZM TWICE	;CF;	DATA RZZ/2.8/
	MOVEM 1,.COMM.+=15  ;KQ   C  DEFAULT VALUE OF SLUR CURVE FACTOR IS 2.8
	MOVE 3,[0.2]	;2	J10=1
	MOVE PLTR+1	;	J4=0
	CAMGE [2.0]	;	KQ=5 
	JRST S21	;	TWICE=-1
	MOVEM 1,TWICE	;C  -1 FOR DISPLAY, USES ONLY 1/3 OF SEGMENTS
	MOVE 3,[0.14]	;	IF(PLT.GE.0)GO TO 21
	CAMGE [3.0]	;	TWICE=0
	JRST S21	;	KQ=1
	ADDM 1,TWICE	;	RWID=.2
	MOVE 3,[0.1]	;	IF(RHT.LT.2)GO TO 21
S21:	MOVEM 3,RWID#	;	TWICE=1
	MOVE STF+=8	;	RWID=.14
	FMPR [7.0]	;C  IF SIZE IS GT.2 3 SLURS ARE DRAWN
	MOVEM RST7	;	IF(RHT.LT.3)GO TO 21
	MOVE 6,.COMM.+6		;R5
	FSBR 6,.COMM.+5		;-R4	AC6 IS RQQ
	MOVE .COMM.+7	;	TWICE=2
	CAMG [1000.0]	;C  IF SIZE IS GE.3 4 SLURS ARE DRAWN
	JRST .+3 	;	RWID=.1
	JSA 16,RNOTE	;21 	RST7=RSTJ2*7.
	.COMM.+7	;	RQQ=R5-R4
	MOVN 8,.COMM.+=29 ;	IF(R6.GT.1000)CALL RNOTE(R6)
	CAIN 8,1	;	GO TO (5,6,7),J8+4
	JRST S7		;(J8=-1)	GO TO 4
	CAIN 8,2	;5 	R=30
	JRST S6		;CC5;	R=32
	CAIE 8,3	;C AFTER DOTTED NOTE
	JRST S4		;	GO TO 8
S5:	MOVE [30.0]	;CC6;	R=18
	JRST S8		;6 	R=22
S6:	MOVE [22.0]	;C BETWEEN NOTES
S8:	MOVN 2,[0.75]	;8 	RX=-0.75
	JRST S9		;CC8;	RX=-1.3
S7:	MOVE [7.0]	; 	GO TO 9
	MOVE 2,STF+=8	;7 	R=7
S9:	FMPR STF+=8	;	RX=RSTJ2
	FADRM  .COMM.+=4
	FADRB 2,.COMM.+7	;9 	CALL RJBX(R)
S4:	FMPR 2,[5.96]		;	R6=R6+RX
	FSBR 2,[596.0]		;4 	RXX=RHORZ(R6)-R3
	FSBR 2,.COMM.+4		;AC2=RXX	RTILT=RQQ*RST7
	MOVE 3,6		;GET RQQ
	FMPR 3,RST7
	MOVEM 3,RTILT
	FMPR 3,3    
	FMPR 2,2
	FADR 3,2
	JSA 16,SQRT	;80 	RX=SQRT(RXX*RXX+RTILT*RTILT)
	3
	MOVEM RX
	CAIE 8,1	;	IF(J8.NE.-1)GO TO 10
	JRST S10
	CAMLE 6,[8.0]	;	IF(RQQ.GT.8)RQQ=8
	MOVE 6,[8.0]
	CAMGE 6,[-8.0]	;	IF(RQQ.LT.-8)RQQ=-8
	MOVE 6,[-8.0]	;CCCC;	RQQ=RQQ*RSTFAC(J2)
	SKIPGE .COMM.+=8	;	IF(R7)RQQ=-RQQ
	MOVNS 6
			;	R3=R3-RQQ*RSTJ2
			;CCC;	R3=R3-RQQ
			;  MOVES STEEP SLUR LEFT OR RIGHT IF P8=-1
			;10 	RJ=ABS(R7)
; R7+100=LEFT HALF SLUR, +200=RIGHT HALF, +300=REVERSE DIRECTION.
			;	IF(RJ.LT.100)RJ=-1
			;	IF(RJ.GE.300)RJ=0
;	R7=AMOD(R7,100.0)
;	R=RDIS*RX*.4
;	L=R
;	L=L*2
C TO INSURE AN EVEN NUMBER OF VECTORS (ONLY 1/2 ARE COMPUTED IN SLOOP)
;	IF(L.LT.60)L=60
;	IF(L.GT.272)L=272
;	IF(J11.EQ.0)GO TO 1
;	R=R*2
;	RZ=L-60
;	J11=RZ * 10./212. +7.
;	RXXX=.02
111;	IF(R.GT.272)J11=J11-RXXX*(R-272)
 ;	IF(J11.LT.7)J11=7
11;	IF(MOD(L/J11,2).NE.0)GO TO 1
C TO INSURE AN UNEVEN NUMBER OF SEGMENTS (SO THE LAST IS BLACK)
;	J11=J11+1
;	GO TO 11
CC;	J11=R/7. 
CC;	IF(J11.LT.7)J11=7
CC;	IF(J11.GT.39)J11=39
CC;	J11=RDIS*L/J11
C FOR DASHED SLURS  
C  L=NUMB OF SEGMENTS IN THE CURVE.

1;	R=CENTR
;	IF(J8.GT.0)GO TO 180
C  JUMP FOR BRACKETS
;	CALL SLOOP

;	IF(J4.NE.0)GO TO 83
87;	CALL LINES(SLURX(J10),SLURY(J10),3)
;	IF(J11.EQ.0)J4=-1
83;	J5=KQ
;	J6=J10
;	J7=L
;	IF(J11.NE.0)GO TO  122
;	IF(J4)GO TO 22
;	J6=L
;	J7=J10
;	J5=-1
22;	DO 88 K=J6,J7,J5
88;	CALL LINES(SLURX(K),SLURY(K),2)
;	GO TO 123

122;	KD=2
;	KT=0
;	KA=1
C THIS WILL MAKE DASHED SLURS  J11 HAS DASH SIZE.
;	DO 188 K=J6,J7,J5
;	KT=KT+1
;	IF(KT.LT.J11)GO TO 188
;	KT=0
;	KD=KD+KA
;	KA=-KA
C  BLANK-DASH FLIP-FLOP
188;	CALL LINES(SLURX(K),SLURY(K),KD)

123;	IF(J5.GT.1)CALL LINES(SLURX(L),SLURY(L),2)
;	IF(TWICE)RETURN
;	TWICE=TWICE-1
;	IF(J8.GT.0)GO TO 182
;	J4=-J4
;	R7=R7+RWID
C  RWID=WIDTH OF SLUR -- SEE DATA
;	GO TO 1
180;	RW=R+R7*RST7
;	TWICE=-1
;	KQ=1
;	RX=RX+R3
CC;	RA=(R5-R4)*RST7
;	IF(J9.EQ.0)GO TO 181
;	TWICE=2
;	RZ=RTILT/(RX-R3)
;	RXX=RX
;	RWID=(R3+RXX)/2.
182;	IF(TWICE.EQ.1)GO TO 183
C  DOES LEFT SIDE FIRST.
;	IF(TWICE.EQ.0)GO TO 184
C LAST IS NUMBER.
;	J8=2
;	RC=RSTJ2*13.
;	RX=RWID-RC
;	RWW=RTILT
185;	RTILT=RZ*(RX-R3)

C  PUT IN FUNC. HERE FOR THIS SLOPE AND FOR PART. BEAMS.

;	GO TO 181
183;	J8=3
;	RX=RXX
;	RTILT=RWW
;	RXX=R3
;	R3=RWID+RC
;	RXX=RZ*(R3-RXX)
;	R=R+RXX
;	RW=RW+RXX
;	GO TO 185

181;	SLURX(1)=R3
;	SLURY(1)=R
;	SLURX(2)=R3
;	SLURY(2)=RW
;	SLURX(3)=RX
;	SLURY(3)=RW+RTILT
;	SLURX(4)=RX
;	SLURY(4)=R+RTILT
;	L=4
;	IF(J8.EQ.2)L=3
;	IF(J8.EQ.3)J10=2
CC;	TWICE=-1
;	GO TO 87
184;	J3=RWID
C  PUT IN VERT. POS. WHEN SLOPE!
;	R4=RQQ/2.+R4+R7-1.
;	R6=0.875
C .875 IS SIZE OF NUM.   R7=1 MAKES ITALIC FONT
;	R7=1.
;	R8=0
;	CALL MAKNUM(R9)
;	END
C  8, POS1, STF, NT1, NT2, POS2, DIP(ABS. UNITS), P8
C        FOR P8: 0= SLUR, 1=BRACKETS, 2=LFT ONLY, 3=RT ONLY